;; tests for flow-graph

;; consider the following for easy debug

;; 1. Turn optimization off, use highest settings for safety and debug
;; (declaim (optimize (safety 3)) (optimize (debug 3)) (optimize (speed 0)))

;; 2. Use step call, e.g. if you have translate-to-c function that uses one argument,
;;    you may use:
;; (step (translate-to-c (get-flow-mappings-1)))




;;;; flow graph data structures


;;;;
;; expression type
(defstruct expression)

;; represents certain simple value being used in function calls
;; or set expressions
;; it might include symbol (e.g. variable reference), number or string
(defstruct (const-value (:include expression) (:conc-name expr-))
  (val nil :type (or symbol string number)))

;; represents lvalues, e.g. those things that potentially could be modified
(defstruct (lvalue (:include expression) (:conc-name expr-)))

(defstruct (var-expression (:include lvalue) (:conc-name expr-))
  (var nil :type symbol))

;; function call
(defstruct (function-call (:include lvalue) (:conc-name expr-))
  ;; origin could be:
  ;;    - a symbol, e.g. foo(1, 2)
  ;;    - other function call expression, e.g. (*pFoo)(1, 2)
  (origin nil :type (or symbol function-call))

  ;; arguments of the function being called
  ;;    - null indicates there is no such arguments
  ;;    - arguments array
  (args nil :type (or null (simple-array expression (*)))))



;; root for all the other nodes
(defstruct (node (:conc-name node-))
  ;; source form the node inferred from
  (source-form nil :type (or null cons))
  ;; next node or null
  (next nil :type (or null node)))


;; atomic expression statement that might be:
;;    - null (e.g. nothing, or `void' in terms of C), <=> no operation
;;    - var, implies symbolic var name
;;    - number or string
(defstruct (atomic (:include node) (:conc-name node-))
  (value nil :type (or number string symbol)))


;; funcall
(defstruct (call (:include node) (:conc-name node-))
  (func nil)
  (args nil :type list))

;; set expression, like `a=b', `foo=dc', etc.
(defstruct (set-expr (:include node) (:conc-name node-))
  (lvalue nil :type node)
  (rvalue nil :type node))

(defstruct (enter-scope (:include node) (:conc-name node-))
  (var nil :type symbol))

(defstruct (leave-scope (:include node) (:conc-name node-))
  (scope-begin nil :type enter-scope))

;; represents if-condition, e.g. if (a == b) { do1(); }
;; `next' member points to then-sequence,
;; `else' member holds else-sequence
(defstruct (if-condition (:include node) (:conc-name node-))
  ;; condition that is tested
  (condition nil :type node)
  ;; then block
  (then nil :type (or null node))
  ;; else block
  (else nil :type (or null node)))



;; utility function that finds tail node
;; e.g. consider a node sequence A->B->C->D
;; for A, B, C or D node this function shall return node D
(defun find-tail-node (n)
  (declare (node n))
  (do nil ((null (node-next n)))
    (setf n (node-next n)))
  n)


;; flow graph c translator

(defstruct c-tran-context
  (ostream nil :type stream)
  (func-map nil :type hash-table)
  (indent 0 :type integer))

(defstruct (c-func (:conc-name func-))
  (c-name nil :type string)

  ;; semantics - one of the following
  ;;   :function
  ;;   :binary-op
  ;;   :unary-op
  (semantics nil :type keyword))


;; you may test it using (declaim (optimize (speed 3) (space 0) (safety 0)))
;; naive conversion of the symbol to the string that represents C-styled name
(defun symbol-to-c-name (sym)
  (declare (symbol sym))
  (let* ((source-name (princ-to-string sym))
	 (result-name (make-string (length source-name))))
    (loop for pos from 0 to (1- (length source-name)) do
	 (let ((ch (aref source-name pos)))
	   (setf
	    (aref result-name pos)
	    (cond
	      ((or
		(and (char>= ch #\a) (char<= ch #\z))
		(and (char>= ch #\0) (char<= ch #\9) (> pos 0))
		(char= ch #\_))
	       ;; leave it as-is in case of matching valid characters range
	       ch)

	      ;; the following strategy is used: all the uppercase symbols
	      ;; will be converted to their lowercase counterparts
	      ((and (char>= ch #\A) (char<= ch #\Z))
	       (code-char (+ (- (char-code ch)
				(char-code #\A))
			     (char-code #\a))))
	      
	      ;; replace all the other characters with an underscore
	      (t #\_)))))
    result-name))

;; converts func-map-list to the hash table with unique keys
(defun create-func-map (func-map-list)
  (let ((result (make-hash-table))
	(name-entries (make-hash-table)))
    (flet ((add-name (id name semantics)
	     (declare (symbol id) (string name) (keyword semantics))
	     ;; check that the name was not previously used
	     (if (gethash name name-entries)
		 (error (format nil "duplicate name entry ~a" name)))
	     ;; mark the name as not a vacant one
	     (setf (gethash name name-entries) t)
	     ;; check that the identifier was not declared before
	     (if (gethash id result)
		 (error (format nil "duplicate identifier ~a" id)))
	     ;; put name to the appropriate place of the identifiers table
	     (setf (gethash id result) (make-c-func :c-name name
						    :semantics semantics))))

      ;; iterate over the given list and fill the result hash table
      (dolist (f func-map-list)
	(typecase f
	  ;; symbol case: infer the name from the symbol itself
	  (symbol (add-name f (symbol-to-c-name f) :function))
	  ;; cons: expect (id name) pair
	  (cons (destructuring-bind (id name &optional &key
					(semantics :function)) f
		  (add-name id name semantics)))
	  ;; unknown function entry
	  (t (error (format nil "unknown function entry ~a" f))))))
    result))




;; convert-to-flow-scheme helpers
(defgeneric process-flow-id (context id args))


;; converts atom from the flow to certain node
(defun convert-atom-to-node (context val)
  (unless context (error "context shall not be null"))
  (make-atomic :value val))

;; checked wrapper for `process-flow-id' function that processes atoms as well as
;; conses
(defun process-flow-expr (context expr)
  (if (consp expr)
      ;; convert expression to the flow node
      (let ((flow-id (car expr)))
	(if (symbolp flow-id)
	    ;; flow-id is a symbol
	    (process-flow-id context flow-id (cdr expr))
	    ;; flow id is not a symbol - emit error
	    (error (format nil "flow expression ~a has first symbol that is not a function: ~a" expr flow-id))))
      
      ;; expr is an atom - convert it appropriately
      (convert-atom-to-node context expr)))


;; function call
(defmethod process-flow-id (context func-id args)
  (let ((func-desc (gethash func-id (c-tran-context-func-map context))))
    (unless func-desc (error (format nil "function ~a was not defined" func-id)))
    (make-call :func func-desc
	       :args (loop for arg in args collect (process-flow-expr context arg)))))

;; scope
(defmethod process-flow-id (context (id (eql 'scope)) args)
  (destructuring-bind (var &rest flow-list) args
    (let* ((enter-scope (make-enter-scope :var var))
	   (leave-scope (make-leave-scope :scope-begin enter-scope))
	   (prev-node enter-scope))

      ;; insert subsequence to the scope nodes
      (dolist (flow-expr flow-list)
	(let ((cur-node (process-flow-expr context flow-expr)))
	  (setf (node-next prev-node) cur-node)
	  (setf prev-node (find-tail-node cur-node))))

      ;; append leave-scope to the end
      (setf (node-next prev-node) leave-scope)

      ;; where the fucking deadlock is???
      ;;(break)

      ;; return first expression
      enter-scope)))

;; set
(defmethod process-flow-id (context (id (eql 'set)) args)
  (destructuring-bind (lvalue rvalue) args
    (make-set-expr :lvalue (process-flow-expr context lvalue)
		   :rvalue (process-flow-expr context rvalue))))

;; if
(defmethod process-flow-id (context (id (eql 'if)) args)
  (destructuring-bind (condition then-block &optional else-block) args
    (make-if-condition
     :condition (process-flow-expr context condition)
     :then (if then-block (process-flow-expr context then-block))
     :else (if else-block (process-flow-expr context else-block)))))

;; return
(defmethod process-flow-id (context (id (eql 'return)) args)
  (format t "return: ~a~%" args))






;; test:
;; (setf fl (getf (get-flow-and-name-mappings-1) :flow))
;; (convert-to-flow-scheme)
;;
;;
(defun convert-to-flow-scheme (context flow-list)
  (let ((result nil)
	(prev-node nil))
    (dolist (flow-expr flow-list)
      ;;(check-type flow-expr cons)
      (let ((cur-node (process-flow-expr context flow-expr)))
	(unless result (setf result cur-node))
	(if prev-node
	    (setf (node-next (find-tail-node prev-node)) cur-node)
	    (setf prev-node cur-node))))
    result))


;; prints characters for C
(defun c-print-character (context ch)
  (let ((output (c-tran-context-ostream context)))
    (case ch
      ;; open block
      (#\{ (write-char #\Newline output)
	   (write-char ch output)
	   (write-char #\Newline output))
      ;; close block
      (#\} (write-char #\Newline output)
	   (write-char ch output))
      ;; comma
      (#\, (write-char #\, output)
	   (write-char #\Space output))
      ;; default case
      (t (write-char ch output)))))

;; expands keywords given to the case keyword form
(defmacro c-case-keyword-form (c-keyword-var &rest keywords-list)
  `(case ,c-keyword-var
     ,@(loop for k in keywords-list collect
	    (list k (string-downcase (princ-to-string k))))
     (t (error (format nil "internal error: unknown keyword '~a'" ,c-keyword-var)))))

;; print keyword
(defun c-print-keyword (context c-keyword)
  (write-string
   ;; keyword string
   (c-case-keyword-form
    c-keyword
    ;; control-flow related keywords
    :if :else :break :for :while :do :goto :return
    ;; type definition-related keywords
    :struct :union :typedef)
   ;; output stream
   (c-tran-context-ostream context)))

;; C printer
(defun c-prn (context val)
  (let ((os (c-tran-context-ostream context)))
    (typecase val
      ;; keyword
      (keyword (c-print-keyword context val))
      
      ;; string
      (string (write-string val os))

      ;; atomic expression - print value
      (atomic (let ((v (node-value val)))
		(typecase v
		  (string (write-char #\" os)
			  (write-string v os)
			  (write-char #\" os))
		  ((or symbol number) (c-prn context v))
		  (t (error (format nil "unexpected atomic's value type: ~a"
				    (type-of v)))))))

      ;; symbol/number is printed using princ-to-string
      ((or symbol number) (write-string (princ-to-string val) os))
      
      ;; chars
      (character (c-print-character context val))
      
      ;; c-func object shall be printed using built-in c-name
      (c-func (write-string (func-c-name val) os))
      ;;(symbol (let ((name (gethash val (c-tran-context-name-map context)))) (write-string (if name name (princ-to-string val)) os)))

      ;; unknown value type
      (t (error (format nil "unknown value of type ~a" (type-of val)))))))

;; prints sequence
(defun c-prns (context &rest vals)
  (dolist (v vals)
    (c-prn context v)))


;; prints node
(defun c-print-node (context node)
  (typecase node

    ;; enter variable scope
    (enter-scope (c-prns context "int" #\Space (node-var node)))

    ;; leave variable scope
    (leave-scope (c-prns context "// leaving scope of " (node-var (node-scope-begin node))))

    ;; set expression
    ;;(set-expr (c-prns context "// set " (node-lvalue node) " to " (node-rvalue node)))
    (set-expr (c-print-node context (node-lvalue node))
	      (c-prn context #\=)
	      (c-print-node context (node-rvalue node)))

    ;; simple evaluation
    (atomic (c-prn context node))

    ;; if
    (if-condition (let ((condition (node-condition node))
			(then (node-then node))
			(else (node-else node)))
		    ;; if statement and condition declaration
		    (c-prns context "if" #\()
		    (c-print-node context condition)
		    (c-prns context #\))

		    ;; then block
		    (c-prn context #\{)
		    (c-print-node-sequence context then)
		    (c-prn context #\})

		    (if else (progn
			       (c-prns context #\Newline "else" #\{)
			       (c-print-node-sequence context else)
			       (c-prn context #\})))))

    ;; call
    (call (let* ((func (node-func node))
		 (func-name (func-c-name func))
		 (args (node-args node)))
	    (case (func-semantics func)
	      ;; function call
	      (:function (progn
			  (c-prns context func-name #\()
			  ;; print each argument
			  (loop for arg in args for arg-index from 0 do
			       (if (> arg-index 0) (c-prn context #\,))
			       (c-print-node context arg))
			  (c-prn context #\))))
	      ;; binary operation
	      (:binary-op (if (/= (length args) 2)
			      (error "invalid arguments"))
			  (c-prn context #\()
			  (c-print-node context (first args))
			  (c-prns context #\Space func-name #\Space)
			  (c-print-node context (second args))
			  (c-prn context #\)))
	      ;; unary operation
	      (:unary-op (if (/= (length args) 1)
			      (error "invalid arguments"))
			  (c-prns context #\( func-name #\Space)
			  (c-print-node context (first args))
			  (c-prn context #\)))
	      ;; unknown function semantics
	      (t (error (format nil
				"unknown function semantics: ~a"
				(func-semantics func)))))))

    ;; unk type
    (t (error (format nil "/* unhandled node of type ~a */" (type-of node))))))

;; detect whether semicolon required
(defun semicolon-required? (node)
  (typecase node
      ;; the following types are not require semicolon at end of the block
      ((or if-condition leave-scope) nil)

      ;; all the other nodes do require semicolon by default
      (t t)))

;; print nodes sequence
(defun c-print-node-sequence (context first-flow-node)
  (let ((first t))
    (do ((node first-flow-node))
	((null node))

      ;; newline if needed
      (if first
	  (setf first nil)
	  (c-prn context #\Newline))
      
      ;; body
      (c-print-node context node)
      ;; add semicolon if needed
      (if (semicolon-required? node) (c-prn context #\;))

      ;; go next
      (setf node (node-next node)))))

;; expect source to be a (list :flow {list} :function-mapping {list})
;; test: (translate-to-c (get-flow-mappings-1) *standard-output*)
(defun translate-to-c (source ostream)
  (let* ((context (make-c-tran-context
		   :ostream ostream
		   :func-map (create-func-map (getf source :function-mapping))))
	 (first-flow-node (convert-to-flow-scheme context (getf source :flow))))

    ;;(break)
    (c-print-node-sequence context first-flow-node)))



;;  00:     t0 = read_num();
;;  01:     if (t0 % 2 == 0)
;;              { printf("t0 is even") } // then-block
;;              { printf("t0 is odd") } // else-block
;;  02:     t0 = t0 + 1
(defun get-flow-mappings-1 ()
  (let ((flow-sequence
	 '((scope t0
	    (set t0 (read-num))
	    (if t0
		(printf "%d, %s, %d" 12 "1" t0))
	    (if (== (mod t0 2) 0)
		(printf "even")
		(printf "odd")))))
	(function-mapping '((read-num "read_num")
			    (mod "%" :semantics :binary-op)
			    (== "==" :semantics :binary-op)
			    (+ "+" :semantics :binary-op)
			    printf)))
    (list :flow flow-sequence :function-mapping function-mapping)))

(defun get-flow-mappings-2 ()
  (let ((flow-sequence '((set t0 1)
			 (set t0 2)))
	(function-mapping nil))
    (list :flow flow-sequence :function-mapping function-mapping)))

(defparameter *v* '((scope t0
		     (set t0 (read-num))
		     (if t0 (printf "1")))
		    (set t0 (+ t0 1))))